Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/database/randomfa/address.frm

Visual Basic Form | 1995-12-29 | 42.0 KB | 1,319 lines

VERSION 2.00
Begin Form frmRecordEditor
   BackColor       =   &H00C0C0C0&
   Caption         =   "Random Access Address File Record Editor"
   ClientHeight    =   5535
   ClientLeft      =   1350
   ClientTop       =   1800
   ClientWidth     =   8505
   ClipControls    =   0   'False
   Height          =   6225
   Icon            =   ADDRESS.FRX:0000
   Left            =   1290
   LinkTopic       =   "Form1"
   ScaleHeight     =   5535
   ScaleWidth      =   8505
   Top             =   1170
   Width           =   8625
   Begin CommandButton cmdOption
      Caption         =   "Jumble Data"
      Height          =   315
      Index           =   10
      Left            =   6870
      TabIndex        =   42
      TabStop         =   0   'False
      Tag             =   "Jumble"
      Top             =   4770
      Width           =   1500
   End
   Begin CommandButton cmdOption
      Caption         =   "Find Deleted"
      Height          =   315
      Index           =   9
      Left            =   5220
      TabIndex        =   15
      TabStop         =   0   'False
      Tag             =   "FindDeleted"
      Top             =   4770
      Width           =   1500
   End
   Begin SSCheck chkSave
      Caption         =   "Show Save Message"
      Height          =   255
      Left            =   6240
      TabIndex        =   41
      TabStop         =   0   'False
      Top             =   3900
      Value           =   -1  'True
      Width           =   2085
   End
   Begin TextBox txtData
      Height          =   285
      Index           =   0
      Left            =   1260
      MaxLength       =   30
      TabIndex        =   28
      Tag             =   "AccountNumber"
      Top             =   120
      Width           =   1755
   End
   Begin CommandButton cmdOption
      Caption         =   "Open File"
      Height          =   315
      Index           =   5
      Left            =   3510
      TabIndex        =   18
      TabStop         =   0   'False
      Tag             =   "Open"
      Top             =   5100
      Width           =   1500
   End
   Begin ListBox lstResults
      Height          =   3735
      Left            =   4590
      Sorted          =   -1  'True
      TabIndex        =   11
      Top             =   90
      Width           =   3735
   End
   Begin SSCommand cmdAbort
      Caption         =   "&Abort Random Generator"
      Font3D          =   1  'Raised w/light shading
      ForeColor       =   &H00FF0000&
      Height          =   315
      Left            =   3000
      TabIndex        =   26
      TabStop         =   0   'False
      Top             =   3930
      Visible         =   0   'False
      Width           =   2325
   End
   Begin TextBox txtData
      Height          =   285
      Index           =   11
      Left            =   1275
      MaxLength       =   15
      TabIndex        =   10
      Tag             =   "Status"
      Top             =   3480
      Width           =   450
   End
   Begin CommandButton cmdOption
      Caption         =   "Exit"
      Height          =   315
      Index           =   8
      Left            =   6870
      TabIndex        =   21
      TabStop         =   0   'False
      Tag             =   "Exit"
      Top             =   5100
      Width           =   1500
   End
   Begin TextBox txtData
      Height          =   285
      Index           =   1
      Left            =   1275
      MaxLength       =   30
      TabIndex        =   0
      Tag             =   "Company"
      Top             =   420
      Width           =   3000
   End
   Begin TextBox txtData
      Height          =   285
      Index           =   10
      Left            =   1275
      MaxLength       =   15
      TabIndex        =   9
      Tag             =   "EMail"
      Top             =   3120
      Width           =   1665
   End
   Begin TextBox txtData
      Height          =   285
      Index           =   9
      Left            =   1275
      MaxLength       =   15
      TabIndex        =   8
      Tag             =   "Fax"
      Top             =   2820
      Width           =   1665
   End
   Begin TextBox txtData
      Height          =   285
      Index           =   8
      Left            =   1275
      MaxLength       =   15
      TabIndex        =   7
      Tag             =   "Telephone"
      Top             =   2520
      Width           =   1665
   End
   Begin TextBox txtData
      Height          =   285
      Index           =   7
      Left            =   1275
      MaxLength       =   15
      TabIndex        =   6
      Tag             =   "PostCode"
      Top             =   2220
      Width           =   1665
   End
   Begin TextBox txtData
      Height          =   285
      Index           =   6
      Left            =   1275
      MaxLength       =   30
      TabIndex        =   5
      Tag             =   "Address3"
      Top             =   1920
      Width           =   3000
   End
   Begin TextBox txtData
      Height          =   285
      Index           =   5
      Left            =   1275
      MaxLength       =   30
      TabIndex        =   4
      Tag             =   "Address2"
      Top             =   1620
      Width           =   3000
   End
   Begin TextBox txtData
      Height          =   285
      Index           =   4
      Left            =   1275
      MaxLength       =   30
      TabIndex        =   3
      Tag             =   "Address1"
      Top             =   1320
      Width           =   3000
   End
   Begin TextBox txtData
      Height          =   285
      Index           =   3
      Left            =   1275
      MaxLength       =   30
      TabIndex        =   2
      Tag             =   "Surname"
      Top             =   1020
      Width           =   3000
   End
   Begin TextBox txtData
      Height          =   285
      Index           =   2
      Left            =   1275
      MaxLength       =   30
      TabIndex        =   1
      Tag             =   "Forename"
      Top             =   720
      Width           =   3000
   End
   Begin CommandButton cmdOption
      Caption         =   "Generate Random Data"
      Height          =   315
      Index           =   7
      Left            =   3000
      TabIndex        =   25
      TabStop         =   0   'False
      Tag             =   "Random"
      Top             =   3930
      Width           =   2325
   End
   Begin CommandButton cmdOption
      Caption         =   "Find Next"
      Enabled         =   0   'False
      Height          =   315
      Index           =   4
      Left            =   3510
      TabIndex        =   14
      TabStop         =   0   'False
      Tag             =   "FindNext"
      Top             =   4770
      Width           =   1500
   End
   Begin SSCommand cmdMove
      Height          =   315
      Index           =   0
      Left            =   2460
      Picture         =   ADDRESS.FRX:0302
      TabIndex        =   24
      TabStop         =   0   'False
      Tag             =   "First"
      Top             =   4380
      Width           =   800
   End
   Begin SSCommand cmdMove
      Height          =   315
      Index           =   1
      Left            =   3300
      Picture         =   ADDRESS.FRX:0460
      TabIndex        =   23
      TabStop         =   0   'False
      Tag             =   "Previous"
      Top             =   4380
      Width           =   800
   End
   Begin SSCommand cmdMove
      Height          =   315
      Index           =   2
      Left            =   4140
      Picture         =   ADDRESS.FRX:05BE
      TabIndex        =   22
      TabStop         =   0   'False
      Tag             =   "Next"
      Top             =   4380
      Width           =   800
   End
   Begin SSCommand cmdMove
      Height          =   315
      Index           =   3
      Left            =   4980
      Picture         =   ADDRESS.FRX:071C
      TabIndex        =   20
      TabStop         =   0   'False
      Tag             =   "Last"
      Top             =   4380
      Width           =   800
   End
   Begin CommandButton cmdOption
      Caption         =   "Find Surname"
      Height          =   315
      Index           =   3
      Left            =   1830
      TabIndex        =   13
      TabStop         =   0   'False
      Tag             =   "FindString"
      Top             =   4770
      Width           =   1500
   End
   Begin CommandButton cmdOption
      Caption         =   "Find Record"
      Height          =   315
      Index           =   2
      Left            =   150
      TabIndex        =   12
      TabStop         =   0   'False
      Tag             =   "FindRecord"
      Top             =   4770
      Width           =   1500
   End
   Begin CommandButton cmdOption
      Caption         =   "Save Changes"
      Height          =   315
      Index           =   6
      Left            =   5220
      TabIndex        =   19
      TabStop         =   0   'False
      Tag             =   "Save"
      Top             =   5100
      Width           =   1500
   End
   Begin CommandButton cmdOption
      Caption         =   "Delete Record"
      Height          =   315
      Index           =   1
      Left            =   1830
      TabIndex        =   17
      TabStop         =   0   'False
      Tag             =   "Delete"
      Top             =   5100
      Width           =   1500
   End
   Begin CommandButton cmdOption
      Caption         =   "Add Record"
      Height          =   315
      Index           =   0
      Left            =   150
      TabIndex        =   16
      TabStop         =   0   'False
      Tag             =   "Add"
      Top             =   5100
      Width           =   1500
   End
   Begin Label lblData
      Alignment       =   1  'Right Justify
      BackColor       =   &H00C0C0C0&
      Caption         =   "Status"
      Height          =   225
      Index           =   11
      Left            =   90
      TabIndex        =   40
      Top             =   3480
      Width           =   1095
   End
   Begin Label lblData
      Alignment       =   1  'Right Justify
      BackColor       =   &H00C0C0C0&
      Caption         =   "EMail"
      Height          =   225
      Index           =   10
      Left            =   90
      TabIndex        =   39
      Top             =   3180
      Width           =   1095
   End
   Begin Label lblData
      Alignment       =   1  'Right Justify
      BackColor       =   &H00C0C0C0&
      Caption         =   "Fax"
      Height          =   225
      Index           =   9
      Left            =   90
      TabIndex        =   38
      Top             =   2880
      Width           =   1095
   End
   Begin Label lblData
      Alignment       =   1  'Right Justify
      BackColor       =   &H00C0C0C0&
      Caption         =   "Telephone"
      Height          =   225
      Index           =   8
      Left            =   90
      TabIndex        =   37
      Top             =   2550
      Width           =   1095
   End
   Begin Label lblData
      Alignment       =   1  'Right Justify
      BackColor       =   &H00C0C0C0&
      Caption         =   "Post Code"
      Height          =   225
      Index           =   7
      Left            =   90
      TabIndex        =   36
      Top             =   2250
      Width           =   1095
   End
   Begin Label lblData
      Alignment       =   1  'Right Justify
      BackColor       =   &H00C0C0C0&
      Caption         =   "Address3"
      Height          =   225
      Index           =   6
      Left            =   90
      TabIndex        =   35
      Top             =   1950
      Width           =   1095
   End
   Begin Label lblData
      Alignment       =   1  'Right Justify
      BackColor       =   &H00C0C0C0&
      Caption         =   "Address2"
      Height          =   225
      Index           =   5
      Left            =   90
      TabIndex        =   34
      Top             =   1650
      Width           =   1095
   End
   Begin Label lblData
      Alignment       =   1  'Right Justify
      BackColor       =   &H00C0C0C0&
      Caption         =   "Address1"
      Height          =   225
      Index           =   4
      Left            =   90
      TabIndex        =   33
      Top             =   1350
      Width           =   1095
   End
   Begin Label lblData
      Alignment       =   1  'Right Justify
      BackColor       =   &H00C0C0C0&
      Caption         =   "Surname"
      Height          =   225
      Index           =   3
      Left            =   90
      TabIndex        =   32
      Top             =   1050
      Width           =   1095
   End
   Begin Label lblData
      Alignment       =   1  'Right Justify
      BackColor       =   &H00C0C0C0&
      Caption         =   "Forename"
      Height          =   225
      Index           =   2
      Left            =   90
      TabIndex        =   31
      Top             =   750
      Width           =   1095
   End
   Begin Label lblData
      Alignment       =   1  'Right Justify
      BackColor       =   &H00C0C0C0&
      Caption         =   "Company"
      Height          =   225
      Index           =   1
      Left            =   90
      TabIndex        =   30
      Top             =   450
      Width           =   1095
   End
   Begin Label lblData
      Alignment       =   1  'Right Justify
      BackColor       =   &H00C0C0C0&
      Caption         =   "Account No"
      Height          =   225
      Index           =   0
      Left            =   90
      TabIndex        =   29
      Top             =   150
      Width           =   1095
   End
   Begin Label lblDeleted
      Alignment       =   2  'Center
      BackColor       =   &H000000FF&
      Caption         =   "<<< Deleted"
      ForeColor       =   &H00FFFFFF&
      Height          =   225
      Left            =   1770
      TabIndex        =   27
      Top             =   3510
      Visible         =   0   'False
      Width           =   1305
   End
   Begin Menu mnuFile
      Caption         =   "&File"
      Begin Menu mnuFileOpen
         Caption         =   "&Open"
      End
      Begin Menu mnuFileLine
         Caption         =   "-"
      End
      Begin Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
   Begin Menu mnuEdit
      Caption         =   "&Edit"
      Begin Menu mnuEditAdd
         Caption         =   "&Add Record"
      End
      Begin Menu mnuEditDelete
         Caption         =   "&Delete Record"
      End
      Begin Menu mnuEditSave
         Caption         =   "&Save Record"
      End
      Begin Menu mnuEditJumble
         Caption         =   "&Jumble Data"
      End
   End
   Begin Menu mnuFind
      Caption         =   "Fin&d"
      Begin Menu mnuFindRecord
         Caption         =   "Find &Record"
      End
      Begin Menu mnuFindSurname
         Caption         =   "Find &Surname"
      End
      Begin Menu mnuFindNext
         Caption         =   "Find &Next"
      End
      Begin Menu mnuFindDeleted
         Caption         =   "Find &Deleted"
      End
   End
   Begin Menu mnuAbout
      Caption         =   "&About"
      Begin Menu mnuAboutProject
         Caption         =   "&Project"
      End
      Begin Menu mnuAboutDataCraft
         Caption         =   "&DataCraft"
      End
   End
Option Explicit
Dim udtDataRecord       As udtRecord    ' Instance of User Defined Data Type
Dim udtCopyRecord       As udtRecord    ' Instance of User Defined Data Type
Dim flngPosition        As Long         ' flngPosition describes presentation order.
Dim flngLastRecord      As Long         ' Last Record tracker
Dim fstrFilename        As String
Dim fintFilenumber      As Integer
Dim findContinue        As Integer
Dim fstrSearch          As String
Sub CleanUpFile ()
    Dim intClearNumber  As Integer
    Dim lngLoop         As Long
    Dim indConfirm      As Integer  'Boolean Indicator (ind...)
    Exit Sub
    If MsgBox("Would you like to recreate and remove duplicate records from the " & fstrFilename & " File?", 32 + 4, "Want Cleanup?") = 7 Then Exit Sub
    indConfirm = False
    Screen.MousePointer = 11
    intClearNumber = FileOpener("~~Tmp~~.Tmp", RANDOMFILE, Len(udtDataRecord), indConfirm)
    For lngLoop = 1 To flngLastRecord
    Get #fintFilenumber, lngLoop, udtDataRecord
    Put #intClearNumber, lngLoop, udtDataRecord
    Next lngLoop
    Close ' Close all files.
    FileCopy "~~Tmp~~.Tmp", fstrFilename
    fintFilenumber = FileOpener(fstrFilename, RANDOMFILE, Len(udtDataRecord), indConfirm)
    Kill "~~Tmp~~.Tmp"
    Screen.MousePointer = 0
End Sub
Sub cmdAbort_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single)
    findContinue = False
    DoEvents
    MsgBox "Aborted Random Data Generator", 48, "Random Data Generator Aborted"
End Sub
Sub cmdAddOption ()
    Dim intLoop     As Integer
    SaveRecordChanges
    If flngLastRecord + 1 <= MAX_RECORDS Then
    For intLoop = 0 To MAX_DATAFIELDS - 1
        txtData(intLoop).Text = ""
    Next intLoop
    GetFields
    flngLastRecord = flngLastRecord + 1
    udtDataRecord.AccountNumber = flngLastRecord
    Put #fintFilenumber, flngLastRecord, udtDataRecord
    flngPosition = flngLastRecord
    ShowRecord
    Else
    MsgBox "Maximum number of records reached in this file", 16, "File Full"
    End If
End Sub
Sub cmdDeleteOption ()
    Dim strMsg      As String
    If flngLastRecord = 1 Then
    strMsg = "This is the last record in the file. Deleting it will destroy"
    strMsg = strMsg + " the whole file."
    strMsg = strMsg + " Record Editor will also be closed."
    strMsg = strMsg + " Choose OK to destroy file."
    If MsgBox(strMsg, 65, "About to delete file!") = 1 Then
        Close (fintFilenumber)
        Kill fstrFilename
        End
    Else
        Exit Sub
    End If
    End If
    If MsgBox("Delete this record?", 32 + 4, "Delete Record") = 6 Then
    flngPosition = Val(txtData(0).Text)
    udtDataRecord.AccountNumber = flngPosition
    udtDataRecord.Status = "D"
    Put #fintFilenumber, flngPosition, udtDataRecord
    ShowRecord
    End If
End Sub
Sub cmdExitOption ()
    SaveRecordChanges
    CleanUpFile
    End
End Sub
Sub cmdFindDeletedOption ()
    On Error GoTo FindDeletedError
    Dim lngRecordNumber     As Long
    Dim strData             As String
    Dim strTab              As String
    Dim indFound            As Integer      ' Boolean Indicator (ind...)
    strTab = Chr$(9)
    SaveRecordChanges
    fstrSearch = "D"
    If fstrSearch > "" Then
    Screen.MousePointer = 11
    lstResults.Clear
    For lngRecordNumber = 1 To flngLastRecord
        Get #fintFilenumber, lngRecordNumber, udtDataRecord
        If Trim$(udtDataRecord.Status) = "D" Then
        strData = udtDataRecord.Surname & strTab
        strData = strData & udtDataRecord.Forename & strTab
        strData = strData & udtDataRecord.AccountNumber & strTab
        lstResults.AddItem strData
        indFound = True
        End If
    Next lngRecordNumber
    Screen.MousePointer = 0
    If indFound = False Then
        MsgBox "Did not find any Deleted Records", 48, "Find Deleted Records"
    End If
    End If
FindDeletedExit:
    Exit Sub
FindDeletedError:
    Screen.MousePointer = 0
    MsgBox "Error while finding Deleted Records: " & Error$, 48, "Find Error"
    Resume FindDeletedExit
End Sub
Sub cmdFindNextOption ()
    Dim lngRecordNumber     As Long
    SaveRecordChanges
    If fstrSearch > "" Then
    Screen.MousePointer = 11
    For lngRecordNumber = flngPosition + 1 To flngLastRecord
        Get #fintFilenumber, lngRecordNumber, udtDataRecord
        If InStr(1, udtDataRecord.Surname, fstrSearch, 1) > 0 Then
        flngPosition = lngRecordNumber
        Screen.MousePointer = 0
        ShowRecord
        SetFocusTo "Surname"
        Exit Sub
        End If
    Next lngRecordNumber
    Screen.MousePointer = 0
    MsgBox "Did not find '" & fstrSearch & "'", 48
    End If
End Sub
Sub cmdFindRecordOption ()
    On Error GoTo FindRecordError
    Dim lngRecordNumber     As Long
    Dim strData             As String
    SaveRecordChanges
    strData = Trim$(InputBox$("Enter the Record Number to Find", "Find a record"))
    If strData > "" Then
    lngRecordNumber = Val(strData)
    If lngRecordNumber >= 1 And lngRecordNumber <= flngLastRecord Then
        flngPosition = lngRecordNumber
        ShowRecord
    Else
        MsgBox lngRecordNumber & " is out of range of 1 and " & Str$(flngLastRecord), 48
    End If
    End If
FindRecordExit:
    Exit Sub
FindRecordError:
    MsgBox "Error while finding record: " & Error$, 48, "Find Error"
    Resume FindRecordExit
End Sub
Sub cmdFindSurnameOption ()
    On Error GoTo FindSurnameError
    Dim lngRecordNumber     As Long
    Dim strData             As String
    Dim strTab              As String
    Dim indFound            As Integer      ' Boolean Indicator (ind...)
    strTab = Chr$(9)
    SaveRecordChanges
    fstrSearch = InputBox$("Enter the whole/part Surname to Find", "Find a record")
    SetCommandEnabled "FindNext", fstrSearch > ""
    If fstrSearch > "" Then
    Screen.MousePointer = 11
    lstResults.Clear
    For lngRecordNumber = 1 To flngLastRecord
        Get #fintFilenumber, lngRecordNumber, udtDataRecord
        If InStr(1, udtDataRecord.Surname, fstrSearch, 1) > 0 Then
        strData = udtDataRecord.Surname & strTab
        strData = strData & udtDataRecord.Forename & strTab
        strData = strData & udtDataRecord.AccountNumber & strTab
        lstResults.AddItem strData
        indFound = True
        'flngPosition = lngRecordNumber
        'Screen.MousePointer = 0
        'ShowRecord
        'SetFocusTo "Surname"
        'Exit Sub
        End If
    Next lngRecordNumber
    Screen.MousePointer = 0
    If indFound = False Then
        MsgBox "Did not find '" & fstrSearch & "'", 48
    End If
    End If
FindSurnameExit:
    Exit Sub
FindSurnameError:
    Screen.MousePointer = 0
    MsgBox "Error while finding records: " & Error$, 48, "Find Error"
    Resume FindSurnameExit
End Sub
Sub cmdJumbleOption ()
    ' Please excuse the naf coding in this procedure
    ' We have a Data Protection Act here in the UK that
    ' Controls the storage of data about individuals
    ' This procedure was quickly written to randomize the data
    ' beyond all recognition and protect the guilty!
    ' I left it intact in case if provoked some ideas for you
    Dim lngOne      As Long
    Dim lngTwo      As Long
    Dim intLoop     As Integer
    Dim strData     As String
    Dim strCopy     As String
    Dim strMsg      As String
    Dim strField    As String
    Dim strStore    As String
    If findContinue = True Then Exit Sub
    If MsgBox("WARNING!! THIS OPTION RANDOMLY SWAPS FIELD DATA FROM ONE RECORD TO ANOTHER AND COMPLETELY DESTROYS THE INTEGRETY OF YOUR DATABASE!!" & Chr$(13) & "DO  YOU WANT TO CONTINUE?", 16 + 4, "JUMBLE CURRENT DATABASE?") = 7 Then Exit Sub
    strStore = cmdAbort.Caption
    cmdAbort.Caption = "&Abort Data Jumble"
    findContinue = True
    cmdAbort.Visible = True
    While findContinue = True
    Randomize
    lngTwo = Int((flngLastRecord - 1 + 1) * Rnd + 1)
    flngPosition = lngTwo
    ShowRecord
    udtCopyRecord = udtDataRecord
    lngOne = lngTwo
    While lngOne = lngTwo
        Randomize
        lngOne = Int((flngLastRecord - 1 + 1) * Rnd + 1)
    Wend
    flngPosition = lngOne
    ShowRecord
    Randomize
    intLoop = Int((10 - 1 + 1) * Rnd + 1)
    Select Case intLoop
        Case 1
        strField = "Forename"
        strData = Trim$(udtDataRecord.Forename)
        strCopy = Trim$(udtCopyRecord.Forename)
        If strData = "Test data" Then strData = "Raymond"
        If strCopy = "Test data" Then strCopy = "Raymond"
        udtDataRecord.Forename = strCopy
        udtCopyRecord.Forename = strData
        Case 2
        strField = "Surname"
        strData = Trim$(udtDataRecord.Surname)
        strCopy = Trim$(udtCopyRecord.Surname)
        If strData = "Test data" Then strData = "Wood"
        If strCopy = "Test data" Then strCopy = "Wood"
        udtDataRecord.Surname = strCopy
        udtCopyRecord.Surname = strData
        Case 3
        strField = "Company"
        strData = Trim$(udtDataRecord.Company)
        strCopy = Trim$(udtCopyRecord.Company)
        If strData = "Test data" Then strData = "DataCraft Development Company"
        If strCopy = "Test data" Then strCopy = "DataCraft Development Company"
        udtDataRecord.Company = strCopy
        udtCopyRecord.Company = strData
        Case 4
        strField = "Address1"
        strData = Trim$(udtDataRecord.Address1)
        strCopy = Trim$(udtCopyRecord.Address1)
        If strData = "Test data" Then strData = "42 John Gooch Drive"
        If strCopy = "Test data" Then strCopy = "42 John Gooch Drive"
        udtDataRecord.Address1 = strCopy
        udtCopyRecord.Address1 = strData
        Case 5
        strField = "Address2"
        strData = Trim$(udtDataRecord.Address2)
        strCopy = Trim$(udtCopyRecord.Address2)
        If strData = "Test data" Then strData = "Holtwhites Hill"
        If strCopy = "Test data" Then strCopy = "Holtwhites Hill"
        udtDataRecord.Address2 = strCopy
        udtCopyRecord.Address2 = strData
        Case 6
        strField = "Address3"
        strData = Trim$(udtDataRecord.Address3)
        strCopy = Trim$(udtCopyRecord.Address3)
        If strData = "Test data" Then strData = "Enfield"
        If strCopy = "Test data" Then strCopy = "Enfield"
        udtDataRecord.Address3 = strCopy
        udtCopyRecord.Address3 = strData
        Case 7
        strField = "PostCode"
        strData = Trim$(udtDataRecord.PostCode)
        strCopy = Trim$(udtCopyRecord.PostCode)
        If strData = "Test data" Then strData = "EN2 8HG"
        If strCopy = "Test data" Then strCopy = "EN2 8HG"
        udtDataRecord.PostCode = strCopy
        udtCopyRecord.PostCode = strData
        Case 8
        strField = "Telephone"
        strData = Trim$(udtDataRecord.Telephone)
        strCopy = Trim$(udtCopyRecord.Telephone)
        If strData = "Test data" Then strData = "0181 367 9278"
        If strCopy = "Test data" Then strCopy = "0181 367 9278"
        udtDataRecord.Telephone = strCopy
        udtCopyRecord.Telephone = strData
        Case 9
        strField = "Fax"
        strData = Trim$(udtDataRecord.Fax)
        strCopy = Trim$(udtCopyRecord.Fax)
        If strData = "Test data" Then strData = "0181 364 5278"
        If strCopy = "Test data" Then strCopy = "0181 364 5278"
        udtDataRecord.Fax = strCopy
        udtCopyRecord.Fax = strData
        Case 10
        strField = "EMail"
        strData = Trim$(udtDataRecord.EMail)
        strCopy = Trim$(udtCopyRecord.EMail)
        If strData = "Test data" Then strData = "100037,37"
        If strCopy = "Test data" Then strCopy = "100037,37"
        udtDataRecord.EMail = strCopy
        udtCopyRecord.EMail = strData
    End Select
    strMsg = "Swapping " & strData & " to " & strCopy
    Me.Caption = strMsg
    flngPosition = lngOne
    UpdateDisplay
    SetFocusTo strField: DoEvents
    SaveRecordChanges
    flngPosition = lngTwo
    udtDataRecord = udtCopyRecord
    UpdateDisplay
    SaveRecordChanges
    Wend
    cmdAbort.Visible = False
    cmdAbort.Caption = strStore
    findContinue = False
End Sub
Sub cmdMove_Click (Index As Integer)
    Dim strMove     As String
    Dim lngTemp     As Long
    Dim strMsg      As String
    strMove = cmdMove(Index).Tag
    SaveRecordChanges
    Select Case strMove
    Case "First"
        lngTemp = 1
    Case "Previous"
        lngTemp = flngPosition - 1
    Case "Next"
        lngTemp = flngPosition + 1
    Case "Last"
        lngTemp = flngLastRecord
    End Select
    If lngTemp < 1 Then
    strMsg = "At beginning of file"
    ElseIf lngTemp > flngLastRecord Then
    strMsg = "At end of file"
    ElseIf lngTemp >= 1 And lngTemp <= flngLastRecord Then
    flngPosition = lngTemp
    ShowRecord
    End If
    If strMsg > "" Then MsgBox strMsg, 48, "Record Navigation"
End Sub
Sub cmdOpenOption (TheDefault As String)
    Dim indConfirm      As Integer  ' Boolean Indicator (ind...)
    indConfirm = True
    If flngLastRecord > 0 Then
    SaveRecordChanges
    CleanUpFile
    End If
    fintFilenumber = 0
    Do While fintFilenumber = 0
    fstrFilename = LCase$(GetFilename("Enter the name of a file to create or open" & Chr$(13) & Chr$(13) & "(an address.rnd file should be available in the current working directory)", TheDefault))
    If fstrFilename = "" Then
        End
    Else
        fintFilenumber = FileOpener(fstrFilename, RANDOMFILE, Len(udtDataRecord), indConfirm)
        If fintFilenumber = 0 Then End
    End If
    Loop
    Initialize
End Sub
Sub cmdOption_Click (Index As Integer)
    Dim strOption       As String
    strOption = cmdOption(Index).Tag
    Select Case strOption
    Case "Add"
        cmdAddOption
    Case "Delete"
        cmdDeleteOption
    Case "FindRecord"
        cmdFindRecordOption
    Case "FindString"
        cmdFindSurnameOption
    Case "FindNext"
        cmdFindNextOption
    Case "FindDeleted"
        cmdFindDeletedOption
    Case "Jumble"
        cmdJumbleOption
    Case "Open"
        cmdOpenOption fstrFilename
    Case "Save"
        cmdSaveOption
    Case "Exit"
        cmdExitOption
    Case "Random"
        cmdRandomOption
    End Select
End Sub
Sub cmdRandomOption ()
    On Error GoTo RandomError
    Dim lngLoop     As Long
    Dim lngTotal    As Long
    Dim lngCount    As Long
    Dim strData     As String
    Dim strFilename As String
    Dim intChannel  As Integer
    Dim lngAccountNumber   As Long
    Dim strCompany         As String * 30
    Dim strForename        As String * 12
    Dim strSurname         As String * 12
    Dim strAddress1        As String * 30
    Dim strAddress2        As String * 30
    Dim strAddress3        As String * 30
    Dim strPostCode        As String * 15
    Dim strTelephone       As String * 15
    Dim strFax             As String * 15
    Dim strEMail           As String * 15
    Dim strStatus          As String * 1
    If MsgBox("THIS OPTION WILL OVERWRITE ALL EXISTING DATA" & Chr$(13) & "DO YOU WANT TO CONTINUE?", 16 + 4, "WARNING!! THIS DELETES ALL CURRENT DATA!!") = 7 Then Exit Sub
    strData = "This is test data for the automatic record generation procedure."
    strData = strData & " We include fairly lenghty text in order to test the searching capabilities of the the instr function."
    strData = strData & " There must be a better way of locating records when using random access files in Visual Basic. "
    strData = "This is test data for the automatic record generation procedure for record number: "
    lngTotal = Val(InputBox$("Enter the number of records to generate (between 1 and  2,147,483,647)", "Number to Generate", "1000"))
    If lngTotal >= 1 And lngTotal <= MAX_RECORDS Then
    findContinue = True
    cmdAbort.Visible = True
    chkSave.Value = False
    intChannel = FreeFile
    strFilename = App.Path & "\random.txt"
    Open strFilename For Input As intChannel
    While lngCount < lngTotal And Err = 0 And findContinue = True And EOF(intChannel) = False
        lngCount = lngCount + 1
        Line Input #intChannel, strData
        lngAccountNumber = Val(strData)
        Line Input #intChannel, strStatus
        Line Input #intChannel, strForename
        Line Input #intChannel, strSurname
        Line Input #intChannel, strCompany
        Line Input #intChannel, strAddress1
        Line Input #intChannel, strAddress2
        Line Input #intChannel, strAddress3
        Line Input #intChannel, strPostCode
        Line Input #intChannel, strTelephone
        Line Input #intChannel, strFax
        Line Input #intChannel, strEMail
        SetDataFor "AccountNumber", lngAccountNumber
        SetDataFor "Status", Trim$(strStatus)
        SetDataFor "Forename", Trim$(strForename)
        SetDataFor "Surname", Trim$(strSurname)
        SetDataFor "Company", Trim$(strCompany)
        SetDataFor "Address1", Trim$(strAddress1)
        SetDataFor "Address2", Trim$(strAddress2)
        SetDataFor "Address3", Trim$(strAddress3)
        SetDataFor "PostCode", Trim$(strPostCode)
        SetDataFor "Telephone", Trim$(strTelephone)
        SetDataFor "Fax", Trim$(strFax)
        SetDataFor "EMail", Trim$(strEMail)

        flngLastRecord = lngAccountNumber
        flngPosition = lngAccountNumber
        SaveRecordChanges
        DoEvents
    Wend
    End If
RandomExit:
    cmdAbort.Visible = False
    Close #intChannel
    findContinue = False
    Exit Sub
RandomError:
    MsgBox "Error while generating random records from file '" & strFilename & "' : " & Error$, 48, "Random Error"
    Resume RandomExit
End Sub
Sub cmdSaveOption ()
    SaveRecordChanges
End Sub
Sub Form_Load ()
    ReDim arrTabs(1)    As Integer
    Dim lngResult       As Long
    Me.Move ((Screen.Width - Me.Width) / 2), ((Screen.Height - Me.Height) / 2)
    ChDrive App.Path
    ChDir App.Path
    Me.Show
    arrTabs(0) = 60
    arrTabs(1) = 500
    lngResult = SendMessage(lstResults.hWnd, LB_SETTABSTOPS, 2, arrTabs(0))
    cmdOpenOption "address.rnd"
End Sub
Sub Form_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error GoTo WriteError
    Dim strFilename     As String
    Dim intChannel      As Integer
    Dim lngLoop         As Long
    If Button = 2 Then
    Screen.MousePointer = 11
    strFilename = App.Path & "\address.asc"
    intChannel = FreeFile
    Open strFilename For Output As intChannel
    For lngLoop = 1 To flngLastRecord
        Get #fintFilenumber, lngLoop, udtDataRecord
        Print #intChannel, Trim$(Str$(udtDataRecord.AccountNumber))
        Print #intChannel, Trim$(udtDataRecord.Status)
        Print #intChannel, Trim$(udtDataRecord.Forename)
        Print #intChannel, Trim$(udtDataRecord.Surname)
        Print #intChannel, Trim$(udtDataRecord.Company)
        Print #intChannel, Trim$(udtDataRecord.Address1)
        Print #intChannel, Trim$(udtDataRecord.Address2)
        Print #intChannel, Trim$(udtDataRecord.Address3)
        Print #intChannel, Trim$(udtDataRecord.PostCode)
        Print #intChannel, Trim$(udtDataRecord.Telephone)
        Print #intChannel, Trim$(udtDataRecord.Fax)
        Print #intChannel, Trim$(udtDataRecord.EMail)
    Next lngLoop
    End If
    Screen.MousePointer = 0
WriteExit:
    Close #intChannel
    Exit Sub
WriteError:
    Screen.MousePointer = 0
    MsgBox "Error while writing records: " & Error$, 48, "Write Error"
    Resume WriteExit
End Sub
Sub Form_Unload (Cancel As Integer)
    End
End Sub
Function GetDataFor (TheField As String, TheDataType) As Variant
    Dim intLoop     As Integer
    For intLoop = 0 To Controls.Count - 1
    If TypeOf Controls(intLoop) Is TextBox Then
        If Controls(intLoop).Tag = TheField Then
        Select Case TheDataType
            Case "Numeric"
            GetDataFor = Val(Controls(intLoop).Text)
            Case "Text"
            GetDataFor = Trim$(Controls(intLoop).Text)
        End Select
        Exit For
        End If
    End If
    Next intLoop
End Function
Sub GetFields ()
    'Transfer the data from the textboxes into the data record
    udtDataRecord.AccountNumber = GetDataFor("AccountNumber", "Numeric")
    udtDataRecord.Status = GetDataFor("Status", "Text")
    udtDataRecord.Forename = GetDataFor("Forename", "Text")
    udtDataRecord.Surname = GetDataFor("Surname", "Text")
    udtDataRecord.Company = GetDataFor("Company", "Text")
    udtDataRecord.Address1 = GetDataFor("Address1", "Text")
    udtDataRecord.Address2 = GetDataFor("Address2", "Text")
    udtDataRecord.Address3 = GetDataFor("Address3", "Text")
    udtDataRecord.PostCode = GetDataFor("PostCode", "Text")
    udtDataRecord.Telephone = GetDataFor("Telephone", "Text")
    udtDataRecord.Fax = GetDataFor("Fax", "Text")
    udtDataRecord.EMail = GetDataFor("EMail", "Text")
End Sub
Sub Initialize ()
    flngLastRecord = LOF(fintFilenumber) \ Len(udtDataRecord)
    flngPosition = 1
    If flngLastRecord < 1 Then
    GetFields
    cmdAddOption
    Else
    ShowRecord
    End If
End Sub
Sub lstResults_Click ()
    Dim strData     As String
    If lstResults.ListIndex > -1 Then
    SaveRecordChanges
    strData = lstResults.List(lstResults.ListIndex)
    strData = ExtractElement(strData, 2)
    flngPosition = Val(Trim$(strData))
    ShowRecord
    SetFocusTo "Surname"
    End If
End Sub
Sub mnuAboutDataCraft_Click ()
    frmAbout.Show 1
    Me.Refresh
    DoEvents
End Sub
Sub mnuAboutProject_Click ()
    frmHelp.Show 1
    Me.Refresh
    DoEvents
End Sub
Sub mnuEditAdd_Click ()
    cmdAddOption
End Sub
Sub mnuEditDelete_Click ()
    cmdDeleteOption
End Sub
Sub mnuEditJumble_Click ()
    cmdJumbleOption
End Sub
Sub mnuEditSave_Click ()
    cmdSaveOption
End Sub
Sub mnuFileExit_Click ()
    cmdExitOption
End Sub
Sub mnuFileOpen_Click ()
    cmdOpenOption "address.rnd"
End Sub
Sub mnuFindDeleted_Click ()
    cmdFindDeletedOption
End Sub
Sub mnuFindNext_Click ()
    cmdFindNextOption
End Sub
Sub mnuFindRecord_Click ()
    cmdFindRecordOption
End Sub
Sub mnuFindSurname_Click ()
    cmdFindSurnameOption
End Sub
Sub OpenFile_Click ()
End Sub
Sub ResetTextBoxes ()
    Dim intLoop     As Integer
    For intLoop = 0 To Controls.Count - 1
    If TypeOf Controls(intLoop) Is TextBox Then
        If Controls(intLoop).Tag > "" Then
        Controls(intLoop).DataChanged = False
        End If
    End If
    Next intLoop
End Sub
Sub SaveRecordChanges ()
    On Error GoTo SaveError
    Dim indChanged  As Integer  'Boolean Indicator (ind...)
    Dim intLoop     As Integer
    For intLoop = 0 To Controls.Count - 1
    If TypeOf Controls(intLoop) Is TextBox Then
        If Controls(intLoop).Tag > "" Then
        If Controls(intLoop).DataChanged = True Then
            indChanged = True
            Exit For
        End If
        End If
    End If
    Next intLoop
    If indChanged = True Then
    GetFields
    Put #fintFilenumber, flngPosition, udtDataRecord
    If Err = 0 And chkSave.Value = True Then
        MsgBox "Saved record " & udtDataRecord.AccountNumber & " OK", 48, "Saved Record"
        ResetTextBoxes
    End If
    End If
SaveExit:
    Exit Sub
SaveError:
    MsgBox "Error while saving record: " & Error$, 48, "Save Error"
    Resume SaveExit
End Sub
Sub SetCommandEnabled (TheField As String, TheMode As Integer)
    Dim intLoop     As Integer
    For intLoop = 0 To Controls.Count - 1
    If TypeOf Controls(intLoop) Is CommandButton Then
        If Controls(intLoop).Tag = TheField Then
        Controls(intLoop).Enabled = TheMode
        Exit Sub
        End If
    End If
    Next intLoop
    MsgBox "Unable to locate Command Button '" & TheField & "'", 48, "Internal Error"
End Sub
Sub SetDataFor (TheField As String, TheData As Variant)
    Dim intLoop     As Integer
    For intLoop = 0 To Controls.Count - 1
    If TypeOf Controls(intLoop) Is TextBox Then
        If Controls(intLoop).Tag = TheField Then
        Controls(intLoop).Text = TheData
        Exit For
        End If
    End If
    Next intLoop
End Sub
Sub SetFocusTo (TheField As String)
    Dim intLoop     As Integer
    For intLoop = 0 To Controls.Count - 1
    If TypeOf Controls(intLoop) Is TextBox Then
        If Controls(intLoop).Tag = TheField Then
        Controls(intLoop).SetFocus
        Exit For
        End If
    End If
    Next intLoop
End Sub
Sub ShowRecord ()
    Get #fintFilenumber, flngPosition, udtDataRecord
    'Transfer the data from the data record to the textboxes
    SetDataFor "AccountNumber", udtDataRecord.AccountNumber
    SetDataFor "Status", Trim$(udtDataRecord.Status)
    SetDataFor "Forename", Trim$(udtDataRecord.Forename)
    SetDataFor "Surname", Trim$(udtDataRecord.Surname)
    SetDataFor "Company", Trim$(udtDataRecord.Company)
    SetDataFor "Address1", Trim$(udtDataRecord.Address1)
    SetDataFor "Address2", Trim$(udtDataRecord.Address2)
    SetDataFor "Address3", Trim$(udtDataRecord.Address3)
    SetDataFor "PostCode", Trim$(udtDataRecord.PostCode)
    SetDataFor "Telephone", Trim$(udtDataRecord.Telephone)
    SetDataFor "Fax", Trim$(udtDataRecord.Fax)
    SetDataFor "EMail", Trim$(udtDataRecord.EMail)
    If Trim$(udtDataRecord.Status) = "D" Then
    lblDeleted.Visible = True
    Else
    lblDeleted.Visible = False
    End If
    lblDeleted.Refresh
    DoEvents
    ResetTextBoxes
    GetFields
    UpdateCaption
    SetFocusTo "Company"
End Sub
Sub txtData_Change (Index As Integer)
    Dim strField        As String
    strField = txtData(Index).Tag
    Select Case strField
    Case "Status"
        If txtData(Index).Text = "D" Then
        lblDeleted.Visible = True
        Else
        lblDeleted.Visible = False
        End If
    End Select
End Sub
Sub txtData_GotFocus (Index As Integer)
    Dim strField        As String
    strField = txtData(Index).Tag
    Select Case strField
    Case "AccountNumber"
        SendKeys "{Tab}"    'don't allow access to record number!
    Case Else
        txtData(Index).BackColor = YELLOW
    End Select
End Sub
Sub txtData_KeyDown (Index As Integer, KeyCode As Integer, Shift As Integer)
    Const KEY_RETURN = &HD
    Const KEY_UP = &H26
    Const KEY_DOWN = &H28
    Select Case KeyCode
    Case KEY_DOWN, KEY_RETURN
        KeyCode = 0
        SendKeys "{Tab}"
    Case KEY_UP
        KeyCode = 0
        SendKeys "+{Tab}"
    End Select
End Sub
Sub txtData_KeyPress (Index As Integer, KeyAscii As Integer)
    Dim strField        As String
    If KeyAscii = 13 Then
    KeyAscii = 0
    Else
    strField = txtData(Index).Tag
    Select Case strField
        Case "PostCode"
        KeyAscii = Asc(UCase$(Chr$((KeyAscii))))
    End Select
    End If
End Sub
Sub txtData_LostFocus (Index As Integer)
    txtData(Index).BackColor = WHITE
End Sub
Sub UpdateCaption ()
    Dim strCaption         As String
    strCaption = fstrFilename & ": Record " & Str$(flngPosition)
    strCaption = strCaption & " of " & Str$(flngLastRecord)
    Me.Caption = strCaption
End Sub
Sub UpdateDisplay ()
    SetDataFor "AccountNumber", udtDataRecord.AccountNumber
    SetDataFor "Status", Trim$(udtDataRecord.Status)
    SetDataFor "Forename", Trim$(udtDataRecord.Forename)
    SetDataFor "Surname", Trim$(udtDataRecord.Surname)
    SetDataFor "Company", Trim$(udtDataRecord.Company)
    SetDataFor "Address1", Trim$(udtDataRecord.Address1)
    SetDataFor "Address2", Trim$(udtDataRecord.Address2)
    SetDataFor "Address3", Trim$(udtDataRecord.Address3)
    SetDataFor "PostCode", Trim$(udtDataRecord.PostCode)
    SetDataFor "Telephone", Trim$(udtDataRecord.Telephone)
    SetDataFor "Fax", Trim$(udtDataRecord.Fax)
    SetDataFor "EMail", Trim$(udtDataRecord.EMail)
End Sub